perm filename EUCLID[G,BGB]1 blob
sn#020189 filedate 1973-01-15 generic text, type T, neo UTF8
00100 TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
00200 COMMENT /
00300
00400 MKTRAN(REFRAME,OPAXCNT, DELTA); MAKE EUCLIDEAN TRANSFORMATION.
00500 NORM(LOCOR);
00600 ORTHO(LOCOR);
00700 *CRUX
00800 *ROTOR
00900 ROTDEL
01000 APTRAN(OBJECT,TRAN); APPLY EUCLIDEAN TRANSFORMATION.
01100 TRANSLATE (Q,R);
01200 ROTATE (Q,R);
01300 DILATE (Q,R);
01400 REFLECT (Q,R);
01500 /
01600
01700 EXTERN ECW,ECCW,OTHER
01800 EXTERN BODY,FCW,FCCW,VCW,VCCW
01900
02000 ;NORM(LOC)
02100 SUBR(NORM)--------------------------------------------------------
02200 BEGIN NORM;NORMALIZE AN ORIENTATION MATRIX.
02300 EXTERN SQRT;CLOBBERS AC1 THRU AC4.
02400 ;PICK'EM UP.
02500 SAVAC(15)↔LACI 5↔HRL ARG1↔BLT 15
02600 ; R ← SQRT(A↑2+B↑2+C↑2); A←A/R; B←B/R; C←C/R;
02700 FOR Q IN (5,10,13){
02800 LAC 1,Q↔FMPR 1,1
02900 LAC 1+Q↔FMPR↔FADR 1,0
03000 LAC 2+Q↔FMPR↔FADR 1,0
03100 CAMN 1,[1.0]↔GO .+6
03200 PUSH P,1↔PUSHJ P,SQRT
03300 FDVR Q,1↔FDVR Q+1,1↔FDVR Q+2,1}
03400 ;PUT'EM DOWN.
03500 CDR ARG1↔LAC 1,0↔LIPI 5↔BLT 8(1)
03600 GETAC(15)↔POP1J↔VAR
03700 BEND;1/14/72------------------------------------------------------
00100 ;ORTHOGONIZE AN ORIENTATION MATRIX.
00200 ;IT IS ASSUMED THAT THE ROW VECTORS ARE UNIT VECTORS.
00300 SUBR(ORTHO)-------------------------------------------------------
00400 BEGIN ORTHO
00500 X←0 ↔ Y←1 ↔ Z←2 ;ADDRESS DISPLACEMENTS.
00600 Q←9 ↔ R←13 ↔ A←14 ↔ B←15 ;ACCUMULATORS.
00700 SAVAC(15)
00800 SETOM FLG# ;FIRST TIME THRU FLAG.
00900 ;PLACE THE MATRIX INTO THE FIRST NINE ACCUMULATORS.
01000 L0: LAC R,ARG1↔SLACI Q,IX(R)↔BLT Q,KZ
01100
01200 ;DOT EACH ROW VECTOR INTO THE NEXT ROW.
01300 FMPR IX,JX ↔FMPR IY,JY ↔FMPR IZ,JZ ↔FADR IX,IY↔FADR IX,IZ
01400 FMPR JX,KX ↔FMPR JY,KY ↔FMPR JZ,KZ ↔FADR JX,JY↔FADR JX,JZ
01500 FMPR KX,IX(R)↔FMPR KY,IY(R)↔FMPR KZ,IZ(R)↔FADR KX,KY↔FADR KX,KZ
01600
01700 ;TAKE ABSOLUTE VALUES AND FIND THE WORST TOTAL COSINE.
01800 MOVMS IX↔MOVMS JX↔MOVMS KX
01900 LAC Q,KX↔FADR KX,JX↔FADR JX,IX↔FADR Q,IX↔EXCH Q,JX↔SETZM SIGN#
02000 LACI 1,IX(R)↔LACI 2,JX(R)↔LACI 3,KX(R) ;GET ROW POINTERS.
02100 CAML Q,IX↔GO .+4↔EXCH 2,1↔EXCH Q,IX↔SETCMM SIGN ;GET 2 BIGGER THAN 1.
02200 CAML KX,Q↔GO .+4↔EXCH 3,2↔EXCH KX,Q↔SETCMM SIGN ;GET 3 BIGGER THAN 2.
02300 CAMG KX,[0.00001]↔GO L1 ;GOOD ENUF FOR GOVERNMENT WORK.
02400
02500 ;STRAIGHTEN UP THE WORST VECTOR.
02600 LAC A,Y(1)↔FMPR A,Z(2)
02700 LAC B,Y(2)↔FMPR B,Z(1)↔FSBR A,B↔DAC A,X(3)
02800 LAC A,X(2)↔FMPR A,Z(1)
02900 LAC B,X(1)↔FMPR B,Z(2)↔FSBR A,B↔DAC A,Y(3)
03000 LAC A,X(1)↔FMPR A,Y(2)
03100 LAC B,X(2)↔FMPR B,Y(1)↔FSBR A,B↔DAC A,Z(3)
03200 SKIPE SIGN↔GO[MOVNS X(3)↔MOVNS Y(3)↔MOVNS Z(3)↔GO .+1]
03300 SKIPN FLG↔GO L1↔SETZM FLG↔GO L0
03400 L1: GETAC(15)↔POP1J
03500 LIT
03600 BEND;1/14/72------------------------------------------------------
00100 ;MATRIX CROSS PRODUCT. S cross Q → R.
00200 ;CLOBBERS 0,1 AND EXPECTS ARGUMENTS IN AC S,Q & R.
00300 ;92 words - 550 useconds.
00400 CRUX: 0
00500 BEGIN CRUX
00600 ACCUMULATORS{S,Q,R}
00700 DEFINE ADR(I,J)<3*I+J-4>
00800 FOR I←1,3{
00900 FOR J←1,3{
01000 LAC ADR(I,1)(S)↔FMPR ADR(1,J)(Q)↔LAC 1,
01100 LAC ADR(I,2)(S)↔FMPR ADR(2,J)(Q)↔FADR 1,
01200 LAC ADR(I,3)(S)↔FMPR ADR(3,J)(Q)↔FADR 1,
01300 DAC 1,ADR(I,J)(R)
01400 }}↔GO@CRUX
01500 BEND;1/14/72------------------------------------------------------
00100 ;ROTDEL(REF,DEL,AXIS,DELTA)
00200 ;Setup a rotation DEL-MATRIX in DEL,
00300 ;with respect to the frame of referance REF,
00400 ;about AXIS 0-X, 1-Y, 2-Z by DETLA radians.
00500 SUBR(ROTDEL)------------------------------------------------------
00600 BEGIN ROTDEL
00700 EXTERN SIN,COS
00800 ACCUMULATORS{S,Q,R,REF,DEL,AXIS}
00900 DAC 12,SAV12
01000 ;SET DEL LOCUS TO REF LOCUS AND CLEAR DEL ORIENTATION.
01100 LAC REF,ARG4↔LAC DEL,ARG3
01200 SLACI XWC(REF)↔LAPI XWC(DEL)↔BLT ZWC(DEL)
01300 SETZM IX(DEL)↔SLACI IX(DEL)↔LAPI IY(DEL)↔BLT KZ(DEL)
01400
01500 ;PLACE SINE(DELTA) AND COSINE(DELTA) INTO DEL'S ORIENTATION.
01600 SETZM SINE#↔LAC 1,[1.0]↔CAR AXIS,ARG2↔JUMPN AXIS,.+6
01700 PUSH P,ARG1↔PUSHJ P,SIN↔DAC 1,SINE#
01800 PUSH P,ARG1↔PUSHJ P,COS
01900 LAC DEL,ARG3
02000 DAC 1,IX(DEL)↔DAC 1,JY(DEL)↔DAC 1,KZ(DEL)
02100 LAC 0,[1.0]↔LAC 1,SINE
02200 CDR AXIS,ARG2↔CAILE AXIS,2↔SETZ AXIS
02300 LSH AXIS,2↔GO .+1(AXIS)
02400 DAC IX(DEL)↔DAC 1,KY(DEL)↔DACN 1,JZ(DEL)↔GO L ;CCW ABOUT I.
02500 DAC JY(DEL)↔DAC 1,IZ(DEL)↔DACN 1,KX(DEL)↔GO L ;CCW ABOUT J.
02600 DAC KZ(DEL)↔DAC 1,JX(DEL)↔DACN 1,IY(DEL)↔L: ;CCW ABOUT K.
02700
02800 ;(transpose(REF)cross(DEL cross REF)) → DEL.
02900 ;BRING 'EM FROM THE REFRAM AND HIT 'EM WITH THE DEL.
03000 LAC DEL,ARG3↔LAC REF,ARG4
03100 SLACI IX(REF)↔LAPI IX+REF↔BLT KZ+REF ;A TERRIBLE PUN ON REF.
03200 LAC S,ARG3↔LAC Q,ARG4↔LACI R,TMP↔JSR CRUX
03300
03400 ;SHRINK AND/OR MIRROR 'EM.
03500 L1: CAR 0,ARG2 ;GET AXIS SELECT BITS.
03600 JUMPE L4 ;THERE AIN'T ANY.
03700 LAC 1,ARG1
03800 TRNN 4↔GO L2↔FMPRM 1,IX(R)↔FMPRM 1,IY(R)↔FMPRM 1,IZ(R)
03900 L2: TRNN 1↔GO L3↔FMPRM 1,JX(R)↔FMPRM 1,JY(R)↔FMPRM 1,JZ(R)
04000 L3: TRNN 2↔GO L4↔FMPRM 1,KX(R)↔FMPRM 1,KY(R)↔FMPRM 1,KZ(R)
04100
04200 ;TRANSPOSE THE REFRAME AND MAP'EM BACK FROM WHERE THEY CAME.
04300 L4: EXCH 6,10↔EXCH 7,13↔EXCH 12,14
04400 LACI S,5↔LACI Q,TMP↔LAC R,ARG3↔JSR CRUX
04500 LAC 12,SAV12
04600 POP4J
04700 SAV12: 0
04800 TMP: BLOCK 9
04900 BEND;1/14/72------------------------------------------------------
00100 ;TRANSLATE(Q,R).
00200 SUBR(TRANSLATE)---------------------------------------------------
00300 BEGIN TRANSL
00400 DEFINE TRAN.{FADRM X,XWC(V)↔FADRM Y,YWC(V)↔FADRM Z,ZWC(V)}
00500 Q←1
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
00700 CDR R,ARG1
00800 LAC X,XWC(R)↔LAC Y,YWC(R)↔LAC Z,ZWC(R)
00900 LAC Q,ARG2↔LAC(1)
01000 FOR @$ Qε{BFEV}{
01100 TLNE(Q$BIT)↔GO Q$TRAN}
01200 LOCOR V,Q↔TRAN.↔POP2J;CAMERA CASE.
01300
01400 ;BODY TRANSLATION.
01500 BTRAN: LAC B,Q↔FCNT 0,B↔CAIN 0,1↔GO L2; ONE FACED BODY.
01600 LAC V,B↔SLACI(VBIT);INITIAL BODY VERTEX.
01700 L1: PVT V,V↔TDNN(V)↔GO L2;SKIP WHEN VERTEX.
01800 TRAN.↔GO L1;TRANSLATE A VERTEX OF THE BODY.
01900 L2: LOCOR V,B↔SKIPN V↔GO L3;BODY LOCUS.
02000 TRAN.
02100
02200 ;...AND ALL THE PARTS OF THIS BODY.
02300 L3: PART N,B↔JUMPL N,.+6
02400 PUSH P,B↔PUSH P,N↔PUSH P,R↔PUSHJ P,TRANSLATE↔POP P,B
02500 CDR N,(P)↔CAIE N,.-2↔POP2J
02600 COPART B,B↔SKIPL V,B↔GO L1↔POP2J
02700
02800 ;FACE TRANSLATION.
02900 FTRAN: LAC F,Q↔NCNT N,F↔PED E0,F↔LAC E,E0; PICK'EM UP.
03000 JUMPE E0,[PFACE B,F↔PVT V,B↔TRAN.↔POP2J]; VERTEX FACE.
03100 JUMPL N,L4↔AOS N↔MOVNS N
03200 PCW 0,E↔CAME 0,E↔GO L5; TEST FOR WIRE.
03300 L4: SETQ(V,{VCW,E,F})↔TRAN.; WIRE OR SHEET'S 1ST VERTEX.
03400 L5: SETQ(V,{VCCW,E,F}); GET VERTEX.
03500 TRAN.↔SETQ(0,{ECCW,E,F}); MOVE IT & GET EDGE.
03600 CAMN 0,E↔POP2J; END OF WIRE.
03700 LAC E,0↔CAMN E,E0↔POP2J; END OF FACE.
03800 AOJL N,L5↔POP2J; END OF SHEET.
03900
04000 ;EDGE TRANSLATION.
04100 ETRAN: LAC E,Q
04200 PVT V,E↔TRAN.
04300 NVT V,E↔TRAN.
04400 POP2J
04500
04600 ;VERTEX TRANSLATION.
04700 VTRAN: LAC V,Q
04800 TRAN.
04900 POP2J
05000 BEND;1/14/72------------------------------------------------------
00100 ;ROTATION'S INNER MOST SUBROUTINE.
00200 ;EXPECTS ARGUMENTS IN V AND R, CLOBBERS 0,1,X,Y,Z.
00300 ; 36 words - 200 useconds.
00400 ROTOR: 0
00500 BEGIN ROTOR
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
00700
00800 LAC X,XWC(V)↔ FSBR X,XWC(R);
00900 LAC Y,YWC(V)↔ FSBR Y,YWC(R);
01000 LAC Z,ZWC(V)↔ FSBR Z,ZWC(R);
01100
01200 DEFINE ROTAT $(Q){
01300 LAC 0,X↔ FMPR 0,Q$X(R)
01400 LAC 1,Y↔ FMPR 1,Q$Y(R)↔ FADR 0,1
01500 LAC 1,Z↔ FMPR 1,Q$Z(R)↔ FADR 0,1}
01600
01700 ROTAT(I)↔ FADR XWC(R)↔ DAC XWC(V)
01800 ROTAT(J)↔ FADR YWC(R)↔ DAC YWC(V)
01900 ROTAT(K)↔ FADR ZWC(R)↔ DAC ZWC(V)
02000
02100 GO @ROTOR
02200 BEND;1/14/72------------------------------------------------------
00010 SUBR(APTRAN)OBJECT,TRAN-------------------------------------------
00020 BEGIN;APPLY EUCLIDEAN TRANSFORMATION - BGB - 15 JANUARY 1973.
00030
00040 BEND;1/15/73------------------------------------------------------
00100 ;DILATE(Q,R)
00200 SUBR(DILATE)------------------------------------------------------
00300 SETOM ROTFLG↔GO ROTATE+1
00400
00500 ;REFLECT(Q,R)
00600 SUBR(REFLECT)-----------------------------------------------------
00700 LACI 1↔DAC ROTFLG↔GO ROTATE+1
00800 ROTFLG: 0
00900
01000 ;ROTATION(Q,R).
01100 SUBR(ROTATE)------------------------------------------------------
01200 BEGIN ROTATE
01300 Q←1
01400 DEFINE ROTA.{JSR ROTOR}
01500 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
01600
01700 SETZM ROTFLG; PURE ROTATION.
01800 CDR R,ARG1
01900 LAC Q,ARG2↔LAC(Q)
02000 FOR @$ Qε{BFEV}{
02100 TLNE(Q$BIT)↔GO Q$ROTA}
02200
02300 ;CAMERA CASE.
02400 LOCOR V,Q↔ROTA.
02500 PUSH P,XWC(R)↔PUSH P,YWC(R)↔PUSH P,ZWC(R)
02600 SETZM XWC(R)↔SETZM YWC(R)↔SETZM ZWC(R)
02700 PUSH P,V
02800 REPEAT 3,{ADDI V,3↔ROTA.↔}
02900 PUSHJ P,NORM
03000 POP P,ZWC(R)↔POP P,YWC(R)↔POP P,XWC(R)
03100 POP2J
00100 ;BODY ROTATION.
00200 BROTA: LAC B,Q↔FCNT 0,B↔CAIN 0,1↔GO L2; ONE FACED BODY.
00300 LAC V,B;INITIAL BODY VERTEX.
00400 L1: PVT V,V↔SLACI(VBIT)↔TDNN(V)↔GO L2;SKIP WHEN VERTEX.
00500 ROTA.↔GO L1;ROTATE A VERTEX OF THE BODY.
00600 L2: LOCOR V,B↔SKIPN V↔GO L3;BODY LOCUS.
00700 ROTA.
00800 PUSH P,XWC(R)↔PUSH P,YWC(R)↔PUSH P,ZWC(R)
00900 SETZM XWC(R)↔SETZM YWC(R)↔SETZM ZWC(R)
01000 PUSH P,V
01100 REPEAT 3,{ADDI V,3↔ROTA.↔}
01200 PUSHJ P,NORM↔ADD P,[XWD 1,1]↔PUSHJ P,ORTHO
01300 POP P,ZWC(R)↔POP P,YWC(R)↔POP P,XWC(R)
01400 ;...AND ALL THE PARTS OF THIS BODY.
01500 L3: PART N,B↔JUMPL N,.+6
01600 PUSH P,B↔PUSH P,N↔PUSH P,R↔PUSHJ P,ROTATE↔POP P,B
01700 CDR N,(P)↔CAIE N,.-2↔POP2J
01800 COPART B,B↔SKIPL V,B↔GO L1↔POP2J
01900
02000 ;FACE ROTATION.
02100 FROTA: LAC F,Q↔NCNT N,F↔PED E0,F↔LAC E,E0; PICK'EM UP.
02200 JUMPE E0,[PFACE B,F↔PVT V,B↔ROTA.↔POP2J]; VERTEX FACE.
02300 JUMPL N,L4↔AOS N↔MOVNS N
02400 PCW 0,E↔CAME 0,E↔GO L5; TEST FOR WIRE.
02500 L4: SETQ(V,{VCW,E,F})↔ROTA.; WIRE OR SHEET'S 1ST VERTEX.
02600 L5: SETQ(V,{VCCW,E,F}); GET VERTEX.
02700 ROTA.↔SETQ(0,{ECCW,E,F}); MOVE IT & GET EDGE.
02800 CAMN 0,E↔POP2J; END OF WIRE.
02900 LAC E,0↔CAMN E,E0↔POP2J; END OF FACE.
03000 AOJL N,L5↔POP2J; END OF SHEET.
03100
03200 ;EDGE ROTATION.
03300 EROTA: LAC E,Q
03400 PVT V,E↔ROTA.
03500 NVT V,E↔ROTA.
03600 POP2J
03700
03800 ;VERTEX ROTATION.
03900 VROTA: LAC V,Q
04000 ROTA.
04100 POP2J
04200 BEND;1/14/72------------------------------------------------------
00100 ;SETUP A EUCLIDEAN TRANSFORMATION MATRIX IN LOCOR Q.
00200 ;OP = 0-TRANSLATION, 1-ROTATION, 2-DILATION, 3-REFLECTION.
00300 ;AXIS = 0-X, 1-Y, 2-Z, (3-X).
00400 ;AXECNT = 0 & 1 for AXIS, 2 for ¬AXIS, 3 for all AXES.
00500
00600 ;TRAN ← MKTRAN(REFRAM,OPAXCNT,DELTA).
00700 SUBR(MKTRAN)REFRAM,OPAXCNT,DELTA → TRAN.--------------------------
00800 BEGIN MKTRAN
00900 ACCUMULATORS{Q,REF,DELTA}
01000 CDR Q,ARG3
01100 LAC DELTA,ARG1
01200
01300 ;UNPACK OPAXCNT AND INSURE ITS LEGALITY.
01400 LAC ARG2
01500 LDB 1,[POINT 3,0,29]↔DAC 1,OP#
01600 LDB 1,[POINT 3,0,32]↔CAIN 1,3↔SETZ 1,↔DAC 1,AXIS#
01700 ANDI 7↔SKIPN↔LACI 1↔DAC AXECNT#
01800
01900 ;SETUP DILATION AXIS SELECT BITS 4-X,1-Y,2-Z IN LEFT HALF OF AXIS.
02000 SKIPN 1↔TRO 1,4
02100 CAIN 2↔TRC 1,7↔CAIN 3↔TRO 1,7↔DIP 1,AXIS
02200
02300 ;TRANSLATION.
02400 SKIPE OP↔GO L1↔CDR 1,AXIS
02500 GO .+1(1)↔GO TX↔GO TY↔GO TZ
02600 TX: LAC IX(Q)↔FMPR DELTA↔DAC XWC(Q)
02700 LAC IY(Q)↔FMPR DELTA↔DAC YWC(Q)
02800 LAC IZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
02900 POP3J
03000 TY: LAC JX(Q)↔FMPR DELTA↔DAC XWC(Q)
03100 LAC JY(Q)↔FMPR DELTA↔DAC YWC(Q)
03200 LAC JZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
03300 POP3J
03400 TZ: LAC KX(Q)↔FMPR DELTA↔DAC XWC(Q)
03500 LAC KY(Q)↔FMPR DELTA↔DAC YWC(Q)
03600 LAC KZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
03700 POP3J
03800
03900 ;COPY Q-FRAME INTO REF AND CALL ROTDEL.
04000 L1: LACI REF,REFRAME
04100 SLACI XWC(Q)↔LAPI XWC(REF)↔BLT KZ(REF)
04200 LAC OP↔CAIGE 2↔ZIP AXIS
04300 CALL ROTDEL,REF,Q,AXIS,DELTA
04400 POP3J
04500 BLOCK 3↔REFRAME: BLOCK 9
04600 BEND;1/15/72------------------------------------------------------
04700
04800 END
04802 EUCLID-EOF.